home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
WAFPEGTP
/
PEGWAF.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-12-31
|
46KB
|
1,479 lines
{$A+,B-,D-,E-,F-,I+,L-,N-,O-,R-,S+,V-}
{$M 16000,0,10000}
program pegwaf;
{
pascal hack of filter.c
from the udg.zip distributed with PMail 2.3(r2)
Main benefit is that it can deliver mail to a remote server
so you only need one gateway for an internet of novell servers
Who needs mhs ?
Copyright (C) 1992 Dr Ross Lazarus
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
Dr Ross Lazarus is the original copyright holder of this code.
Email: rossl@gmu.wh.su.edu.au
Mail: Department of Community Medicine,
Westmead Hospital
Westmead, NSW 2145
Australia
Fax: (+61 2) 689 1049
see original comments reproduced below
rossl@gmu.wh.su.oz.au
Started june 10 1992
+ added compiler directives to remove remote server access for a public
release of the source without that unit January 1994 rml
+ added code to locate first non local drive - use instead of default F:
also changed from m: to p: as remote drive
and changed pmgate.sys to use z: as the netware drive. This makes it
possible to use machines which have lastdrive=j in them for multiplatter
or other perversions. May 22 1993 rml
+ altered received by lines in response to suggestions april 1993
+ added standalone operation feb 93
+ writec bug found and fixed when string too long...
+ added code to fix the ccmail zap in the .xqt file ! rml 14 sept 1992
+ added window code for announcements so PMail screen is restored to
original condition. Fixed default remote login as guest, no pass
3/9/92 rml
+ added code to zap crap added by cc:mail when forwarding - @aaEXTERNAL
gets added to the address causing the mail to be bounced angrily. This
is now fixed automatically.
+ added code to write all outgoing mail to an outbox specified in static
file as pw.outbox in waffle type format. Updates index file and
creates new file if necessary rml 25/8/92. Problem. The pegwaf remote
login as well as everyone on the gateway server need rcws rights, so
anyone can read this file !!!! Not ideal but at least it seems to
work. Might be more elegant for this to happen before a poll or when
there's incoming mail ?
+ added code to check that this is a receipt confirmation - no fussing
with screen even if beta as it causes confusion ! 21/8/92 rml
+ added code to generate 4 digit unique waffle outgoing spool file names
to overcome the danger inherent in not checking that the file already
exists in the spool directory first. Also, waffle does not like
non numeric file names - uuq does not work if letter in filename.
17/august 1992 rml
+ changed udg parameters to avoid problems with long return addresses
exceeding the dos command line limit of ?127 characters. Now gets
date and user from dos and netware respectively. Set the udg screen
of pconfig to use
uucpmail ~c ~t [remote server] [remote userid] [remote password]
10/august 1992 rml
+ added detach_from_fileserer call to detach properly after leaving
remote server. Also added realname in brackets after from: field
+ if organ set in waffle static file, an organization: line added to
headers of mail going out.
+ PMail putting blanks in reply-to: which is confusing some mailers -
blank reply-to: now crunched - passed through if has an address
+ if fails for any reason, tries to bounce the message. Assumes netmail
lives in f:\mail
+ if 8th parameter, then gateway is assumed to be on a remote server
with p8 = servername, p9 = remotehostloginid, p10 = remotehostpassword.
because of limitations in parameter passing, the default of path of
\waffle\system\static is assumed for the waffle static file
Otherwise the waffle static file must be available as the WAFFLE
environment variable and the waffle server is assumed to be the
currently logged one.
default waffle static file f:\waffle\system\static assumed
if no env variable set 23/7/92 rml
+ xqt and dat files must have NEWLINE ONLY - not crlf pairs 8/9/92 rml
}
(*
from
* filter.c
* a program to take the output produced by Pegasus Mail/PC in standalone
* mode, and place it appropriately. with associated
* support .cmd and .xqt files for mail processing using the Waffle BBS uucico
* and uuxqt programs.
*
* Pegasus Mail/PC (C) Copyright 1990, 1991, David Harris, Dunedin, New Zealand
* WAFFLE (C) Copyright 1991 by Darkside International of Mountain View CA.
*
* Author: Brendan Murray, Dunedin, New Zealand
* Permission is granted to do whatever you like with this code. Just about
* anyone ought to be able to improve on it. No warranty whatsoever is granted
* or implied.
*
* Actions
* 1. Take the RFC 822 message produced by PMail and prepend a
* uucp acceptible From line
* 2. Create a .cmd file to tell UUCICO what to do
* 3. Create a .xqt file to tell UUXQT what to do at the other end
*)
{$define single}
(*
To compile this public code release, single MUST be defined. Otherwise
you need remote novell server login/map code which will be provided for
an appropriate fee to those wanting it
*)
{$ifdef single}
uses dos,crt,novell,awindow;
{$else}
uses dos,crt,novell,novell2,awindow;
{$endif}
const
firstdrive : string[2] = 'F:';
copyright = 'Copyright Dr Ross Lazarus, 1992. This is FREE COPYRIGHT software.';
copyright2 = 'If you were charged anything for this software, please contact the author.';
pmenvar = 'PMUSER'; { standalone dos environment variable -> user name }
standalone : boolean = false;
containerparam = 1;
toparam = 2;
rservparam = 3;
ruserparam = 4;
hostlogin : string[50] = 'GUEST';
rpassparam = 5;
hostpass : string[40] = '';
toline = 'TO:';
ccmailstuff = '@aaEXTERNAL';
replyto = 'REPLY-TO:';
subject = 'SUBJECT:';
confirmation : boolean = false;
confirm = 'SUBJECT:RECEIPTCONFIRMATION';
from = 'FROM:';
userobject = 1;
remotedrive = 'P:';
PMailext = '.CNM'; { new file extension for bounce if fails }
netmaildir : string = '\mail';
defaultwafdir : string = '\WAFFLE\SYSTEM\STATIC';
newline = chr($0a);
nullc = chr($01);
mailsep : string[4] = nullc + nullc + nullc + nullc;
hn = 'UUCPNAME'; { constants to look for in waffle static file }
sm = 'SMARTHOST';
sp = 'SPOOL';
tz = 'TIMEZONE';
org = 'ORGAN';
nn = 'NODE';
ob = 'PW.OUTBOX';
outboxindexext = 'i';
outboxext = 'f';
waffleset = 'WAFFLE'; { dos env var name of waffle static file path }
datext = '.DAT'; { file name extensions for uucico }
xqtext = '.XQT';
prog = 'PegWaf';
progname = 'PegWaf. Waffle 1.65 UDG for the Pegasus EMailer';
version = 'v0.34s 94.12.31';
ver = version + ', Enquiries: rossl@gmu.wh.su.edu.au';
ccmailzap : boolean = false;
killsent = true;
{ set to true to delete PMail temporary files on completion }
type
hexidtype = array[1..4] of byte;
_datestring = string[10];
timetype = record
h,m,s,s100 : word;
end;
windex = record { a waffle mailbox index file record }
offset : longint;
length : longint;
stuff : array[1..28] of byte;
end;
var
remotegateway : boolean;
station,defaultserverid,remotehandle,remoteserverid : integer;
regs : registers;
f : file;
outfile,infile : text;
dat_FileName,cmd_FileName,xqt_FileName,
shorthostname,
HostName, (* this host *)
SmartHost, (* who sends things on for us *)
Spool, (* where to put things *)
TimeZone, (* for the header *)
Organization,(* more header *)
outbox, (* pw outbox *)
nodename, (* this hosts internet name *)
drive,dir,wafname,ext,wafdir,sender,null,uservername,
containername,realname,homedir : string[100];
tmpstring : string;
rc,i,cntr,cntr2,dummy : integer;
rights : byte;
ch : char;
datesent : string;
started,now : longint;
t : timetype;
function msec(t : timetype) : longint;
{
convert time to 100ths of sec since midnite
}
begin
with t do
msec := s100 + 100*s + 6000*m + 360000*h;
end; { msec }
Procedure WriteC( St:string ; LineNO : integer);
var
m,w,l : integer;
st2 : string;
begin
m := (lo(windmax) - lo(windmin));
w := m div 2; { half width }
l := length(st);
if (l >= m) then
begin
st := copy(st,1,m);
l := m;
end;
gotoxy(succ(w - (length(St) div 2)),Lineno);
write(st);
end; { writec }
procedure wait;
var
c : char;
begin
writec('Press any key to continue',succ(wherey));
while keypressed do
c := readkey;
repeat
until keypressed;
c := readkey;
end;
procedure badnews(s : string);
{
announce s as bad news and exit
}
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' ' + version + ' Fatal Error');
writec(s,2);
wait;
closewindow;
wait;
halt(1);
end; { badnews }
function hexidtostring(x : hexidtype) : string;
{
translate a 4 byte address into a numeric string
}
const
HEXDIGITS : Array [0..15] of char = '0123456789081726';
var
hex_id : string;
id : array[1..4] of byte absolute x;
begin
hex_id := '';
hex_id := hexdigits[Id[1] shr 4]; { lower nibble }
hex_id := hex_id + hexdigits[Id[1] and $0F]; { upper }
hex_id := hex_id + hexdigits[Id[2] shr 4];
hex_id := hex_id + hexdigits[Id[2] and $0F];
hex_id := hex_id + hexdigits[Id[3] shr 4];
hex_id := hex_id + hexdigits[Id[3] and $0F];
hex_id := hex_id + hexdigits[Id[4] shr 4];
hex_id := hex_id + hexdigits[Id[4] and $0F];
hexidtostring := hex_id;
end;
function exists(fn : string) : boolean;
{
return true if fn is a file name
}
var
s : searchrec;
begin
findfirst(fn,anyfile,s);
exists := (doserror = 0) ;
end;
function UpcaseStr(S : String) : String;
(* converts a string to upper case *)
var
P : Integer;
begin
for P := 1 to Length(S) do
S[P] := Upcase(S[P]);
UpcaseStr := S;
end; { Upcasestr }
function lowercaseStr(S : String) : String;
(* converts a string to lower case *)
var
P : Integer;
c : char;
begin
for P := 1 to Length(S) do
begin
c := s[p];
if (c >= 'A') and (c <= 'Z') then
S[P] := chr(ord(c) + ord(' '));
end;
lowercaseStr := S;
end; { lowercasestr }
function trim(trime : String) : String;
{ trim trailing blanks by adjusting the length byte at trime[0] }
const
blank = ' ';
var
l : integer;
begin
l := ord(trime[0]);
while (l > 0) and (trime[l] = blank) do
l := pred(l);
trime[0] := chr(l);
trim := trime;
end; { trim }
function mirt(trime : String) : String;
{ trim all blanks }
const
blank = ' ';
var
p,l : integer;
s : string;
begin
p := 1;
s := '';
l := ord(trime[0]);
if l > 0 then
begin
while (p <= l) and (trime[p] = blank) do
p := succ(p); { point to first non blank }
s := copy(trime,p,999);
end;
mirt := s;
end; { mirt }
function noblanks(trime : String) : String;
{ trim all blanks }
const
blank = ' ';
var
l : integer;
t : string;
begin
t := '';
for l := 1 to length(trime) do
if (trime[l] <> blank) then
t := t + trime[l];
noblanks := t;
end; { noblanks }
function before(sep : string ; s : string) : string;
{
return characters up to sep in s
if no sep, return whole of s
}
var
i : integer;
begin
i := pos(sep,s);
if (i = 0) then
before := s
else
before := copy(s,1,pred(i));
end;
function after(sep :string ; var s : string) : string;
{
return characters after sep in s
if no sep, returns null string
}
var
i,j,l : integer;
begin
l := length(s);
j := length(sep);
i := pos(sep,s);
while (copy(s,i+j,j) = sep) and (i < l) do
inc(i,j);
if (i = 0) or (i >= l) then
after := ''
else
after := copy(s,i + j,999);
end; { after }
{---------------- date and time support ------------------}
const
daypos = 1;
monthpos = 3;
Limit : Array[1..13] of Integer = (31,29,31,30,31,30,31,31,30,31,30,31,31);
MthTab : Array[1..12] of String[9] = ('Jan','Feb','Mar',
'Apr','May','Jun','Jul',
'Aug','Sep','Oct',
'Nov','Dec');
DayTab : Array[0..6] of String[9] = ('Sun','Mon','Tue',
'Wed','Thu','Fri',
'Sat');
Function SysTime : String;
Var
H, M, S : String[2];
hh,mm,ss,s100 : word;
Begin
gettime(hh,mm,ss,s100);
Str(hh:2, H);
Str(mm:2, M);
Str(ss:2, S);
if H[1] = ' ' then H[1] := '0';
if M[1] = ' ' then M[1] := '0';
if S[1] = ' ' then S[1] := '0';
SysTime := H + ':' + M + ':' + S
End;
Function rfc822date : String;
Var
I : Integer;
S1,S2,today : String[30];
dd,mm,yy,d,hh,ss,s100 : word;
ds : string[2];
ys : string[4];
status,mn : integer;
Begin
getdate(yy,mm,dd,d);
str(dd,ds);
str(yy,ys);
S1 := Trim(daytab[D])+', ' + trim(ds) + ' ' + Trim(mthtab[mm])+' ' + ys;
rfc822Date:= s1 + ' ' + systime + ' ' + timezone;
End;
function getmaildir : string;
{
get station and then scan bindery for this user and
return hexid plus netmaildir as users mail dir
needed to bounce mail
}
var
uname,uid : string[80];
stat,retcode : integer;
begin
if standalone then
getmaildir := homedir
else
begin
uid := '';
getstation(stat,retcode);
getuser(stat,uname,retcode);
gethexid(uname,uid,retcode);
if (retcode = 0) and (uid > '') then
getmaildir := firstdrive + netmaildir + '\' + uid
else
getmaildir := homedir;
end; { not standalone }
end; { getmaildir }
procedure parse(s : string);
{
extract waffle static file things needed to rewrite the
PMail container file into a form suitable for uucico to export
}
var
uppers : string;
found : boolean;
function find(id,usource,source : string; var dest : string) : boolean;
{
seek id in the source string
if found, return whatever starts with the first alphabetic character
after the id label
}
var
temps : string;
function alphaafter(sep,ups,s : string ) : string;
{
return first alpha characters after sep in s
if no sep, returns null string
uses uppercase version of sep and s to find substring
}
const alpha : set of char = ['0'..'9','A'..'z','+','-'];
var
i,j,l : integer;
rets : string;
begin
sep := upcasestr(sep);
rets := '';
l := length(s);
j := length(sep);
i := pos(sep,ups);
if (i <> 0) then
begin
i := i + j;
while not (ups[i] in alpha) and (i < l) do
inc(i);
if (i > 0) and (i <= l) then
rets := copy(s,i,l);
end; { not there }
alphaafter := rets;
end; { alphaafter }
begin { find }
if (pos(id,usource) = 1) then
begin
dest := '';
temps := alphaafter(id,usource,source);
if (temps = '') then
badnews('Blank ' + id + ' specified in ' + wafdir)
else
begin
dest := temps;
find := true;
end;
end { leave dest alone if id not found }
else
find := false;
end; { find }
begin { parse the waffle static dir line s }
s := mirt(s);
uppers := upcasestr(s);
found := false;
found := find(hn,uppers,s,hostname);
if not found then
found := find(sm,uppers,s,smarthost);
if not found then
found := find(tz,uppers,s,timezone);
if not found then
found := find(sp,uppers,s,spool);
if not found then
found := find(org,uppers,s,organization);
if not found then
found := find(ob,uppers,s,outbox);
if not found then
found := find(nn,uppers,s,nodename);
end; { parse }
procedure getwafflesetup;
{
read static file for essential configuration details
}
begin
{$i-}
assign(infile,wafdir);
reset(infile);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
badnews(prog + ' ERROR: Unable to open ' + wafdir);
tmpstring := '';
timezone := '';
hostname := '';
smarthost := '';
spool := '';
organization := '';
outbox := '';
nodename := '';
while not eof(infile) do
begin
readln(infile,tmpstring);
if (tmpstring[1] <> '#') and (tmpstring[1] <> ';') then
parse(tmpstring);
end; { eof }
close(infile);
if (timezone = '') then
badnews(prog + ' ERROR: No TimeZone in Waffle Static file ' + wafdir);
if (hostname = '') then
badnews(prog + ' ERROR: No HostName in Waffle Static file ' + wafdir);
if (smarthost = '') then
badnews(prog + ' ERROR: No SmartHost in Waffle Static file ' + wafdir);
if (spool = '') then
badnews(prog + ' ERROR: No Spool in Waffle Static file ' + wafdir);
if (nodename = '') then
badnews(prog + ' ERROR: No Node name in Waffle Static file ' + wafdir);
if (outbox <> '') then { just in case an extension supplied }
outbox := before('.',outbox);
if (pos('.',smarthost) <> 0) then
badnews(prog + ' ERROR: Illegal smarthost parameter in Waffle static file');
if (pos('!',smarthost) <> 0) then
smarthost := before('!',smarthost);
end; { getwafflesetup }
function getnewfilename(dirtocheck : string) : string;
{
make a random filename which does not yet exist there yet
}
var
fn : string;
function randstr : string;
{
return a 4 character string of random hex digits
Looks at turbo randseed which is a (4 byte) longint
and converts it to a hex string (8 char) as a file name
}
var
l : longint;
h : hexidtype absolute l;
w : word;
begin { randstr }
w := random(maxint);
l := randseed; { get longint version }
randstr := copy(hexidtostring(h),1,4);
end; { randstr }
begin { getnewfilename }
repeat
fn := randstr;
until not exists(dirtocheck + fn + '.DAT');
getnewfilename := fn;
end; { getnewfilename }
procedure writespoolfiles;
{
do all the work of rewriting the spooled mail file and writing the
local and spooled control files
Note problems associated with being on a remote gateway if
remotegateway is true
}
var
teststring,s : string[80];
c : char;
endofheader : boolean;
ib,ob : array[1..4096] of byte;
lines : word;
i : integer;
begin { writespoolfiles }
lines := 0;
Spool := Spool + '\' + smarthost + '\';
(* drive and directory from Spool *)
fsplit(Spool, drive, dir, ext);
(* file name from input arguments *)
fsplit(paramstr(containerparam), null, containername, s);
if remotegateway then
begin
if (copy(drive,2,1) = ':') then { must kludge remote drive }
drive := remotedrive + copy(drive,3,999)
end;
wafname := getnewfilename(drive + dir);
(* put 'em together and what do you get? *)
dat_filename := drive + dir + wafname + '.DAT';
(*
* create the data file for mailing
*)
{$i-}
assign(outfile,dat_filename);
settextbuf(outfile,ob);
rewrite(outfile);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
badnews(prog + ' ERROR: Unable to open ' + dat_filename + ' for output');
containername := upcasestr(mirt(paramstr(containerparam)));
{$i-}
assign(infile,containername);
settextbuf(infile,ib);
reset(infile);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
badnews(prog + ' ERROR: Unable to open file ' + containername + ' for input');
write(outfile,'From ',sender,' ',datesent,' remote from ',HostName,newline);
write(outfile,'Received: from ',uservername,' by ',nodename,newline);
write(outfile,' (PMail+UDG ',prog,' ',version,') id ',wafname, ' for ',
paramstr(toparam),';',newline);
write(outfile,' ',rfc822date,newline);
endofheader := false;
while not eof(infile) do
begin
readln(infile,tmpstring);
inc(lines);
if not endofheader and (tmpstring = '') then
begin
endofheader := true;
if (organization > '') then
write(outfile,'Organization: ',organization,newline);
end;
if not endofheader then
begin
teststring := noblanks(upcasestr(tmpstring));
if (teststring <> replyto) then
begin { ignore blank reply-to: lines }
if (pos(from,teststring) = 1) then
begin
if (realname > '') then { add realname to from: line }
if (pos('(',tmpstring) = 0) then { not there yet }
tmpstring := tmpstring + ' (' + realname + ')';
end;
if (pos(confirm,teststring) <> 0) then
confirmation := true;
if (pos(toline,teststring) = 1) then
begin
i := pos(ccmailstuff,tmpstring);
if (i <> 0) then { zap ccmail crap }
begin
tmpstring := copy(tmpstring,1,pred(i));
ccmailzap := true;
end;
end;
write(outfile,tmpstring,newline);
end
else
begin { zap blank reply to }
writeln(prog,' WARNING - Blank reply-to zapped');
delay(1000);
end;
end
else
write(outfile,tmpstring,newline);
if (lines mod 100) = 0 then
write('.');
end;
close(infile);
close(outfile);
{ now shorten hostname for xqt etc }
shorthostname := mirt(copy(hostname,1,7));
(*
* create the '.CMD' file - commands to UUCICO (?)
* Format:
* S 0051.DAT D.home0051 brendan - 0051.DAT 0666
* S 0051.XQT X.home0051 brendan - 0051.XQT 0666
*
* (roughly)
* SEND local-filename as-filename from - ????? unix-file-mode
*)
fsplit(dat_FileName, dir, wafname, ext);
cmd_FileName := dir + wafname + '.CMD';
{$i-}
assign(outfile,cmd_filename);
rewrite(outfile);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
badnews(prog + ' ERROR: Unable to open CMD file ' + cmd_filename + ' for output');
dat_filename := wafname + datext;
xqt_filename := wafname + xqtext;
writeln(outfile,'S ',dat_filename,' D.',shorthostname,wafname,' ',sender,
' - ',dat_filename,' 0666');
writeln(outfile,'S ',xqt_filename,' X.',shorthostname,wafname,' ',sender,
' - ',xqt_filename,' 0666');
close(outfile);
(*
* Create the '.XQT' file -- commands to uuxqt at the other end!
*
*
* Format:
* U brendan home
* Z
* F D.home0051
* I D.home0051
* C rmail brendan
*
* where the commands defined in the uuxqt file are (as stated by
* Ian Taylor (Ian@airs.com, uunet!airs!ian) in a newsitem posted
* to comp.unix.internals 4 Apr 1992)
*
* 'Here are the commands defined in uuxqt files:
*
* C command-line
* I standard-input
* O standard-output [ system ]
* F required-file filename-to-use
* R requestor-address
* U user system
* Z (acknowledge if command failed; default)
* N (no acknowledgement on failure)
* n (acknowledge if command succeeded)
* B (return command input on error)
* e (process with sh)
* E (process with exec)
* M status-file
* # comment '
*
*)
xqt_filename := dir + wafname + xqtext;
{$i-}
assign(outfile,xqt_filename);
rewrite(outfile);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
badnews(prog + ' ERROR: Unable to open XQT file ' + xqt_filename + ' for output');
tmpstring := paramstr(toparam);
i := pos(ccmailstuff,tmpstring);
if (i <> 0) then { zap ccmail crap }
begin
tmpstring := copy(tmpstring,1,pred(i));
ccmailzap := true;
end;
write(outfile,'U ',sender,' ',hostname,newline);
write(outfile,'R ',sender,' ',hostname,newline);
write(outfile,'Z',newline);
write(outfile,'F D.',shorthostname,wafname,newline);
write(outfile,'I D.',shorthostname,wafname,newline);
write(outfile,'C rmail ',tmpstring,newline);
close(outfile);
end;
function findandmap(s : string) : string;
{
return waffle static file path if can successfully parse parameter 8
into a servername, volume, path to static file and if we can attach
and map to it using the current wafpeg userid/password defined as
constants above
If no luck, bounce outgoing mail to sender
}
var
umaildir,staticstring,tmpstring,remotevol,
remoteserver,remotepath,rdir,rname,rext,newpath : string[80];
dummy : integer;
procedure bounceit;
{
send it back
}
var
newfilename : string;
function getnewfilename : string;
{
make a random filename which does not yet exist here
}
var
fn : string;
function randstr : string;
{
return a 4 character string of random hex digits
Looks at turbo randseed which is a (4 byte) longint
and converts it to a hex string (4 char) as a file name
}
var
l : longint;
w : word;
h : hexidtype absolute l;
begin { randstr }
w := random(maxint);
l := randseed; { get longint version }
randstr := copy(hexidtostring(h),1,4);
end; { randstr }
begin { getnewfilename }
randomize;
repeat
fn := randstr + PMailext;
until not exists(umaildir + '\' + fn);
getnewfilename := umaildir + '\' + fn;
end; { getnewfilename }
begin { bounceit }
umaildir := getmaildir;
newfilename := getnewfilename;
window(5,10,75,25,fc,bc,drev,shad);
windowtitle(prog + ' Fatal error');
writeln('Your PMail UDG configuration may be wrong or the');
writeln('remote server might be down or otherwise not cooperative');
writeln('Your outgoing mail will now be returned to you and will appear');
writeln('as new mail so you can try to send it later when the problem is fixed');
if (umaildir = homedir) then
writeln('It will appear as file ',newfilename);
wait;
closewindow;
{$i-}
assign(outfile,newfilename);
rewrite(outfile);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,25,fc,bc,drev,shad);
windowtitle(prog + ' Fatal error');
writeln('Unable to open ',newfilename,' for output');
writeln('Your mail is left as ',paramstr(containerparam),', write this down so you can');
writeln('retrieve it for resending');
wait;
closewindow;
if remotegateway then
begin
logout_from_file_server(remoteserverid);
detach_from_file_server(remoteserverid,dummy);
end;
halt(1);
end;
{$i-}
assign(infile,paramstr(containerparam));
reset(infile);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,25,fc,bc,drev,shad);
windowtitle(prog + ' Fatal error');
writeln('Unable to open PMail container file ',
paramstr(containerparam),' for input');
wait;
closewindow;
close(outfile);
if remotegateway then
begin
logout_from_file_server(remoteserverid);
detach_from_file_server(remoteserverid,dummy);
end;
halt(1);
end;
while not eof(infile) do
begin
readln(infile,tmpstring);
writeln(outfile,tmpstring);
end;
close(infile);
close(outfile);
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Function Completed');
writec('Mail bounced',2);
wait;
closewindow;
end; { bounceit }
{$ifdef single}
begin { findandmap }
window(5,10,75,25,fc,bc,drev,shad);
windowtitle(prog + ' Fatal error');
writeln('Sorry, this version cannot deal with remote novell servers');
writeln('Contact rossl@gmu.wh.su.edu.au for details of the version you need');
wait;
closewindow;
close(outfile);
halt(1);
end;
{$else}
begin { findandmap }
staticstring := '';
if pos(s,'/') <> 0 then
begin { path has been supplied eg gmu/sys:waffle\system.static - parse }
remoteserver := upcasestr(before('/',s));
remotepath := after('/',s);
end
else
begin { use default path for waffle static file }
remoteserver := upcasestr(s);
remotepath := '\waffle\system\static';
end;
if (pos(':',remotepath) > 0) then { parse vol name eg sys:}
begin
remotevol := before(':',remotepath) + ':';
remotepath := after(':',remotepath);
end
else
remotevol := 'SYS:';
fsplit(remotepath,rdir,rname,rext);
if (copy(rdir,length(rdir),1) = '\') then
rdir := copy(rdir,1,pred(length(rdir)));
if (copy(rdir,1,1) <> '\') then
rdir := '\' + rdir;
newpath := remotedrive + rdir;
remoteserverid := login(remoteserver,userobject,hostlogin,hostpass);
if (remoteserverid > 0) then
begin { m:=sys:waffle\system\static,etc }
remotegateway := true;
if mapremotedrive(remotedrive + '=' + remotevol,newpath,remoteserverid,remotehandle) then
begin
{$i-}
chdir(newpath); { m:\waffle\system eg }
{$i+}
dummy := ioresult;
if (dummy = 0) then
staticstring := newpath + '\' + rname + rext
else
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Fatal Configuration error');
writeln('Unable to change to ',newpath);
writeln('Please let your network supervisor know that the gateway is broken');
wait;
closewindow;
end;
end
else
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Fatal Configuration error');
writeln('Able to login, but unable to map to ',remotepath);
writeln('Server ',remoteserver,' or your PMail UDG might be broken');
writeln('See your network supervisor for help');
wait;
closewindow;
end;
end
else
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Fatal Configuration error');
writeln('Unable to log in to ',remoteserver,' as ',hostlogin,'.');
writeln('That server might be down or the userid and/or your ');
writeln('PMail UDG might be broken - ask your network supervisor');
wait;
closewindow;
end;
if (staticstring = '') then
begin { failed - return to default server and bounce }
set_preferred_connection_id(defaultserverid);
bounceit;
if remotegateway then
begin
logout_from_file_server(remoteserverid);
detach_from_file_server(remoteserverid,dummy);
end;
halt(1);
end;
findandmap := staticstring;
end;
{$endif}
procedure deleteold;
begin { delete old mail if got this far }
{$i-}
assign(f,paramstr(containerparam));
erase(f);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Probable Configuration error');
writeln(progname,' ERROR: unable to erase old PMail temporary file ',
paramstr(containerparam));
wait;
closewindow;
if remotegateway then
begin
logout_from_file_server(remoteserverid);
detach_from_file_server(remoteserverid,dummy);
end;
halt(1);
end;
{$i+}
end; { delete old file on completion }
(*
procedure saygone;
{
tell user message appears to have gone
}
begin
if realname = '' then
realname := sender;
with t do
gettime(h,m,s,s100);
started := msec(t);
window(2,9,78,21,fc,bc,dnorm,shad);
windowtitle(prog + ' ' + ver);
writec('PMail has called ' + progname ,1);
writec(copyright,2);
writec(copyright2,3);
if standalone then
writec('(STANDALONE MODE - no Netware detected !)',4);
writec('Your mail has been queued for delivery, and',5);
writec('will soon be on its way out of here',6);
writec('First detected netware drive = ' + firstdrive,7);
if ccmailzap then
writec('cc:mail stupidity has been repaired !',8);
case (random(29)) of
1:writec('All care, no responsibility',9);
2:writec('There is no (apparent) immediate cause for alarm',9);
3:writec('Your mileage may vary; Void where prohibited; Unsuitable for minors',9);
4:writec('Don''t Panic!',9);
5:writec('The more things change, the more they stay different',9);
6:writec('Please DO NOT adjust your computer',9);
7:writec('If anything possibly can go wrong, it will.',9);
8:writec('Things always go wrong at the worst possible time.',9);
9:writec('And now back to your normal programme',9);
10:writec('RELAX !!! It''s only ones and zeros',9);
11:writec('Death is Nature''s way of telling you to slow down',9);
12:writec('This sentence is untrue. (Think about it)',9);
13:writec(realname + ' CANNOT believe this sentence without being inconsistent',9);
14:writec('Shit Happens',9);
15:writec('Don''t press <Cntl><Alt><Del> to continue',9);
16:writec('Cats crawl under Gates, Everything crawls under Windows',9);
17:writec('Incest (n): sibling revelry',9);
18:writec('SYSTEM ERROR: Hit Any User to Continue',9);
19:writec('Cocaine is nature''s way of telling you that you have too much money',9);
20:writec('WINDOWS ERRORS #39: Cannot open Window. Please use the door',9);
21:writec('APATHY ERROR: Don''t bother hitting any keys at all',9);
22:writec('FAMOUS WINDOWS ERRORS #23: It''s really not your fault. Really',9);
23:writec('WINDOWS ERROR #1: All windows errors are due to Installing windows..',9);
24:writec('WINDOWS ERROR #9: No one will ever see this error. Ever. No one.',9);
25:writec('Never argue with a fool. Onlookers might not know the difference',9);
26:writec('I thought YOU did the backup ?!?!?',9);
27:writec('The attention span of a computer is about as long as the power cord.',9);
28:writec('Recursion (n): See "Recursion"',9);
end;
writec('Press a key to continue or wait for a few seconds...',10);
if (pos('ß',ver) <> 0) then
writec('This is a BETA TEST VERSION - PLEASE DO NOT DISTRIBUTE',12);
repeat
with t do
gettime(h,m,s,s100);
now := msec(t);
until keypressed or (now > (started + 500));
if keypressed then
ch := readkey;
closewindow;
end; { advertise }
*)
procedure makecopy;
var
s,st : string;
ix,lastix : windex;
ofile,ifile : file of windex;
newstart,clength : longint;
name,dir,ext : string;
begin { we have an outbox - copy this outgoing mail there }
if remotegateway then
begin { ensure outbox is on remote server }
if (pos(':',outbox) <> 0) then
outbox := after(':',outbox);
outbox := remotedrive + outbox;
end;
{$i-}
s := outbox + '.' + outboxext;
if not exists(s) then
begin
assign(infile,s);
rewrite(infile);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Configuration Problem');
writec('Sorry - cannot create a new outbox - ' + s,3);
wait;
closewindow;
exit;
end;
close(infile);
s := outbox + '.' + outboxindexext;
assign(ifile,s);
rewrite(ifile);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Configuration Problem');
writec('Sorry - cannot create a new outbox index - ' + s,3);
wait;
closewindow;
exit;
end;
close(ifile);
end; { new outbox }
s := outbox + '.' + outboxext;
assign(outfile,s);
append(outfile);
write(outfile,mailsep);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Mail Archiving Problem');
writec('Cannot write mail item separator to outbox ' + s,3);
wait;
closewindow;
exit;
end;
assign(infile,paramstr(containerparam));
reset(infile);
dummy := ioresult;
if (dummy <> 0) then
begin
s := paramstr(containerparam);
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Mail Archiving Problem');
writec('Cannot open ' + s + ' to copy to outbox',3);
wait;
closewindow;
exit;
end;
clength := 0;
while not eof(infile) do
begin
readln(infile,s);
inc(clength,length(s)); { count length }
inc(clength,2); { add crlf }
writeln(outfile,s);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Mail Archiving Problem');
writec('Write error on outbox copy ' + s + ' is the disk full ??',3);
wait;
closewindow;
exit;
end;
end;
close(infile);
close(outfile);
s := outbox + '.' + outboxindexext;
st := outbox + '.' + '~~~';
assign(ofile,st);
rewrite(ofile);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Mail Archiving Problem');
writeln('Cannot rewrite ',st, '. Is it write protected ??');
wait;
closewindow;
exit;
end;
assign(ifile,s);
reset(ifile);
while not eof(ifile) do
begin { make a new copy and keep the last index pointer }
read(ifile,lastix);
write(ofile,lastix);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Mail Archiving Problem');
writec('Write error on ' + st + '. Is the disk full ??',3);
wait;
closewindow;
exit;
end;
end; { eof (ifile) }
close(ifile);
erase(ifile);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Mail Archiving Problem');
writec('Cannot erase ' + s + '. Is it write protected ??',3);
wait;
closewindow;
exit;
end;
fillchar(lastix.stuff,sizeof(lastix.stuff),0); { clear it }
inc(lastix.offset,lastix.length + 4); { new start - sep and prev length }
lastix.length := clength; { length of this message }
write(ofile,lastix); { update the index file }
close(ofile);
fsplit(s,dir,name,ext);
chdir(dir);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Mail Archiving Problem');
writec('Cannot change directory to ' + dir,3);
wait;
closewindow;
exit;
end;
s := name + '.' + outboxindexext;
st := name + '.~~~';
assign(f,st);
rename(f,s);
dummy := ioresult;
if (dummy <> 0) then
begin
window(5,10,75,15,fc,bc,drev,shad);
windowtitle(prog + ' Mail Archiving Problem');
writeln('Cannot rename outbox index file ',st,' to ',s);
writeln('Ask the Supervisor for ALL rights to the outbox directory');
writeln('Tell her to read the documentation !');
wait;
closewindow;
exit;
end;
{ out file renamed to old name ie outbox.i }
{$i+}
end;
begin { main }
randomize; { init new file name generator }
if not apiavailable then
begin
standalone := true;
realname := '';
station := 0;
sender := getenv(pmenvar);
if sender > '' then
sender := lowercasestr(sender)
else
begin
writeln('DOS environment variable ',pmenvar,' is NOT available');
writeln('Please alter your AUTOEXEC.BAT to define one. See documentation');
writeln('Terminating abnormally - mail NOT SENT !');
delay(2000);
halt(1);
end;
end
else
begin
getdir(0,homedir);
get_default_connection_id(defaultserverid);
getstation(station,dummy);
getuser(station,sender,dummy);
get_realname(sender,realname,dummy);
if (dummy <> 0) then
realname := ''
else
realname := trim(realname);
getservername(uservername,dummy);
sender := lowercasestr(sender);
firstdrive := first_networked_drive + ':';
end; { netware }
remotegateway := false;
if (paramcount < 2) then
begin
window(5,10,75,24,fc,bc,drev,shad);
windowtitle(prog + ' Configuration/Installation Problem');
writec(progname,1);
writec(ver,2);
writec('Usage: ' + prog + ' container_file to_line [remote details]',4);
str(paramcount,tmpstring);
writec('First detected netware drive = ' + firstdrive,5);
writec('Called with ' + tmpstring + ' parameters',6);
writeln;
for i := 1 to paramcount do
begin
str(i,tmpstring);
writeln('Parameter' + tmpstring + ' = ',paramstr(i));
end;
wait;
closewindow;
halt(1);
end;
if (paramcount > 2) and not standalone then
begin { must be a remote server - seek and attach to it }
if paramcount > 3 then
hostlogin := paramstr(ruserparam);
if paramcount > 4 then
hostpass := paramstr(rpassparam);
wafdir := findandmap(paramstr(rservparam));
end
else
begin { find waffle static file from dos set variable }
wafdir := getenv(waffleset);
if (wafdir = '') then
wafdir := firstdrive + defaultwafdir;
end;
getwafflesetup;
datesent := rfc822date;
if standalone then
uservername := sender + '@' + hostname
else
uservername := uservername + '/' + sender;
uservername := lowercasestr(uservername);
writespoolfiles;
if (outbox > '') then
makecopy;
if remotegateway and not standalone then
begin
logout_from_file_server(remoteserverid);
detach_from_file_server(remoteserverid,dummy);
{$i-}
chdir(homedir);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
writeln(progname,' ERROR - Unable to change back to ',homedir);
end;
if killsent then
deleteold
else
begin
writeln('Old container file NOT KILLED as run in debug mode');
delay(1000);
end;
(*
if not confirmation then
saygone;
*)
end.
{ pegwaf.pas }